home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / games / life.el.z / life.el
Encoding:
Text File  |  1998-05-21  |  10.0 KB  |  290 lines
  1. ;;; life.el --- John Horton Conway's `Life' game for GNU Emacs
  2.  
  3. ;; Copyright (C) 1988 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Kyle Jones <kyle@uunet.uu.net>
  6. ;; Keywords: games
  7.  
  8. ;; This file is part of XEmacs.
  9.  
  10. ;; XEmacs is free software; you can redistribute it and/or modify it
  11. ;; under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; XEmacs is distributed in the hope that it will be useful, but
  16. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18. ;; General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  22. ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  23. ;; 02111-1307, USA.
  24.  
  25. ;;; Synched up with: FSF 19.34.
  26.  
  27. ;;; Commentary:
  28.  
  29. ;; A demonstrator for John Horton Conway's "Life" cellular automaton
  30. ;; in Emacs Lisp.  Picks a random one of a set of interesting Life
  31. ;; patterns and evolves it according to the familiar rules.
  32.  
  33. ;;; Code:
  34.  
  35. (defconst life-patterns
  36.   [("@@@" " @@" "@@@")
  37.    ("@@@ @@@" "@@  @@ " "@@@ @@@")
  38.    ("@@@ @@@" "@@   @@" "@@@ @@@")
  39.    ("@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@")
  40.    ("@@@@@@@@@@")
  41.    ("   @@@@@@@@@@       "
  42.     "     @@@@@@@@@@     "
  43.     "       @@@@@@@@@@   "
  44.     "@@@@@@@@@@          "
  45.     "@@@@@@@@@@          ")
  46.    ("@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@" "@")
  47.    ("@               @" "@               @"  "@               @"
  48.     "@               @" "@               @"  "@               @"
  49.     "@               @" "@               @"  "@               @"
  50.     "@               @" "@               @"  "@               @"
  51.     "@               @" "@               @"  "@               @")
  52.    ("@@               " " @@              " "  @@             "
  53.     "   @@            " "    @@           " "     @@          "
  54.     "      @@         " "       @@        " "        @@       "
  55.     "         @@      " "          @@     " "           @@    "
  56.     "            @@   " "             @@  " "              @@ "
  57.     "               @@")
  58.    ("@@@@@@@@@" "@   @   @" "@ @@@@@ @" "@ @   @ @" "@@@   @@@" 
  59.     "@ @   @ @" "@ @@@@@ @" "@   @   @" "@@@@@@@@@")]
  60.   "Vector of rectangles containing some Life startup patterns.")
  61.  
  62. ;; Macros are used macros for manifest constants instead of variables
  63. ;; because the compiler will convert them to constants, which should
  64. ;; eval faster than symbols.
  65. ;;
  66. ;; Don't change any of the life-* macro constants unless you thoroughly
  67. ;; understand the `life-grim-reaper' function.
  68.  
  69. (defmacro life-life-char () ?@)
  70. (defmacro life-death-char () (1+ (life-life-char)))
  71. (defmacro life-birth-char () 3)
  72. (defmacro life-void-char () ?\ )
  73.  
  74. (defmacro life-life-string () (char-to-string (life-life-char)))
  75. (defmacro life-death-string () (char-to-string (life-death-char)))
  76. (defmacro life-birth-string () (char-to-string (life-birth-char)))
  77. (defmacro life-void-string () (char-to-string (life-void-char)))
  78. (defmacro life-not-void-regexp () (concat "[^" (life-void-string) "\n]"))
  79.  
  80. (defmacro life-increment (variable) (list 'setq variable (list '1+ variable)))
  81.  
  82.  
  83. ;; list of numbers that tell how many characters to move to get to
  84. ;; each of a cell's eight neighbors.
  85. (defconst life-neighbor-deltas nil)
  86.  
  87. ;; window display always starts here.  Easier to deal with than
  88. ;; (scroll-up) and (scroll-down) when trying to center the display.
  89. (defconst life-window-start nil)
  90.  
  91. ;; For mode line
  92. (defconst life-current-generation nil)
  93. ;; Sadly, mode-line-format won't display numbers.
  94. (defconst life-generation-string nil)
  95.  
  96. (defvar life-initialized nil
  97.   "Non-nil if `life' has been run at least once.")
  98.  
  99. ;;;###autoload
  100. (defun life (&optional sleeptime)
  101.   "Run Conway's Life simulation.
  102. The starting pattern is randomly selected.  Prefix arg (optional first
  103. arg non-nil from a program) is the number of seconds to sleep between
  104. generations (this defaults to 1)."
  105.   (interactive "p")
  106.   (or life-initialized
  107.       (random t))
  108.   (setq life-initialized t)
  109.   (or sleeptime (setq sleeptime 1))
  110.   (life-setup)
  111.   (life-display-generation sleeptime)
  112.   (catch 'life-exit
  113.     (while t
  114.       (let ((inhibit-quit t))
  115.     (life-grim-reaper)
  116.     (life-expand-plane-if-needed)
  117.     (life-increment-generation)
  118.     (life-display-generation sleeptime)))))
  119.  
  120. (defalias 'life-mode 'life)
  121. (put 'life-mode 'mode-class 'special)
  122.  
  123. (defun life-setup ()
  124.   (let (n)
  125.     (switch-to-buffer (get-buffer-create "*Life*") t)
  126.     (erase-buffer)
  127.     (kill-all-local-variables)
  128.     ;; XEmacs change:
  129.     (when (featurep 'scrollbar)
  130.       (set-specifier scrollbar-height 0 (current-buffer))
  131.       (set-specifier scrollbar-width 0 (current-buffer)))
  132.     (setq case-fold-search nil
  133.       mode-name "Life"
  134.       major-mode 'life-mode
  135.       truncate-lines t
  136.       life-current-generation 0
  137.       life-generation-string "0"
  138.       mode-line-buffer-identification '("Life: generation "
  139.                         life-generation-string)
  140.       fill-column (1- (window-width))
  141.       life-window-start 1)
  142.     (buffer-disable-undo (current-buffer))
  143.     ;; stuff in the random pattern
  144.     (life-insert-random-pattern)
  145.     ;; make sure (life-life-char) is used throughout
  146.     (goto-char (point-min))
  147.     (while (re-search-forward (life-not-void-regexp) nil t)
  148.       (replace-match (life-life-string) t t))
  149.     ;; center the pattern horizontally
  150.     (goto-char (point-min))
  151.     (setq n (/ (- fill-column (save-excursion (end-of-line) (point))) 2))
  152.     (while (not (eobp))
  153.       (indent-to n)
  154.       (forward-line))
  155.     ;; center the pattern vertically
  156.     (setq n (/ (- (1- (window-height))
  157.           (count-lines (point-min) (point-max)))
  158.            2))
  159.     (goto-char (point-min))
  160.     (newline n)
  161.     (goto-char (point-max))
  162.     (newline n)
  163.     ;; pad lines out to fill-column
  164.     (goto-char (point-min))
  165.     (while (not (eobp))
  166.       (end-of-line)
  167.       (indent-to fill-column)
  168.       (move-to-column fill-column)
  169.       (delete-region (point) (progn (end-of-line) (point)))
  170.       (forward-line))
  171.     ;; expand tabs to spaces
  172.     (untabify (point-min) (point-max))
  173.     ;; before starting be sure the automaton has room to grow
  174.     (life-expand-plane-if-needed)
  175.     ;; compute initial neighbor deltas
  176.     (life-compute-neighbor-deltas)))
  177.  
  178. (defun life-compute-neighbor-deltas ()
  179.   (setq life-neighbor-deltas
  180.     (list -1 (- fill-column)
  181.           (- (1+ fill-column)) (- (+ 2 fill-column))
  182.           1 fill-column (1+ fill-column)
  183.           (+ 2 fill-column))))
  184.  
  185. (defun life-insert-random-pattern ()
  186.   (insert-rectangle
  187.    (elt life-patterns (random (length life-patterns))))
  188.   (insert ?\n))
  189.  
  190. (defun life-increment-generation ()
  191.   (life-increment life-current-generation)
  192.   (setq life-generation-string (int-to-string life-current-generation)))
  193.  
  194. (defun life-grim-reaper ()
  195.   ;; Clear the match information.  Later we check to see if it
  196.   ;; is still clear, if so then all the cells have died.
  197.   (store-match-data nil)
  198.   (goto-char (point-min))
  199.   ;; For speed declare all local variable outside the loop.
  200.   (let (point char pivot living-neighbors list)
  201.     (while (search-forward (life-life-string) nil t)
  202.       (setq list life-neighbor-deltas
  203.         living-neighbors 0
  204.         pivot (1- (point)))
  205.       (while list
  206.     (setq point (+ pivot (car list))
  207.           char (char-after point))
  208.     (cond ((eq char (life-void-char))
  209.            (subst-char-in-region point (1+ point)
  210.                      (life-void-char) 1 t))
  211.           ((< char 3)
  212.            (subst-char-in-region point (1+ point) char (1+ char) t))
  213.           ((< char 9)
  214.            (subst-char-in-region point (1+ point) char 9 t))
  215.           ((>= char (life-life-char))
  216.            (life-increment living-neighbors)))
  217.     (setq list (cdr list)))
  218.       (if (memq living-neighbors '(2 3))
  219.       ()
  220.     (subst-char-in-region pivot (1+ pivot)
  221.                 (life-life-char) (life-death-char) t))))
  222.   (if (null (match-beginning 0))
  223.       (life-extinct-quit))
  224.   (subst-char-in-region 1 (point-max) 9 (life-void-char) t)
  225.   (subst-char-in-region 1 (point-max) 1 (life-void-char) t)
  226.   (subst-char-in-region 1 (point-max) 2 (life-void-char) t)
  227.   (subst-char-in-region 1 (point-max) (life-birth-char) (life-life-char) t)
  228.   (subst-char-in-region 1 (point-max) (life-death-char) (life-void-char) t))
  229.  
  230. (defun life-expand-plane-if-needed ()
  231.   (catch 'done
  232.     (goto-char (point-min))
  233.     (while (not (eobp))
  234.       ;; check for life at beginning or end of line.  If found at
  235.       ;; either end, expand at both ends,
  236.       (cond ((or (eq (following-char) (life-life-char))
  237.          (eq (progn (end-of-line) (preceding-char)) (life-life-char)))
  238.          (goto-char (point-min))
  239.          (while (not (eobp))
  240.            (insert (life-void-char))
  241.            (end-of-line)
  242.            (insert (life-void-char))
  243.            (forward-char))
  244.        (setq fill-column (+ 2 fill-column))
  245.        (scroll-left 1)
  246.        (life-compute-neighbor-deltas)
  247.        (throw 'done t)))
  248.       (forward-line)))
  249.   (goto-char (point-min))
  250.   ;; check for life within the first two lines of the buffer.
  251.   ;; If present insert two lifeless lines at the beginning..
  252.   (cond ((search-forward (life-life-string)
  253.              (+ (point) fill-column fill-column 2) t)
  254.      (goto-char (point-min))
  255.      (insert-char (life-void-char) fill-column)
  256.      (insert ?\n)
  257.      (insert-char (life-void-char) fill-column)
  258.      (insert ?\n)
  259.      (setq life-window-start (+ life-window-start fill-column 1))))
  260.   (goto-char (point-max))
  261.   ;; check for life within the last two lines of the buffer.
  262.   ;; If present insert two lifeless lines at the end.
  263.   (cond ((search-backward (life-life-string)
  264.               (- (point) fill-column fill-column 2) t)
  265.      (goto-char (point-max))
  266.      (insert-char (life-void-char) fill-column)
  267.      (insert ?\n)
  268.      (insert-char (life-void-char) fill-column)
  269.      (insert ?\n)
  270.      (setq life-window-start (+ life-window-start fill-column 1)))))
  271.  
  272. (defun life-display-generation (sleeptime)
  273.   (goto-char life-window-start)
  274.   (recenter 0)
  275.   
  276.   ;; Redisplay; if the user has hit a key, exit the loop.
  277.   (or (eq t (sit-for sleeptime))
  278.       (throw 'life-exit nil)))
  279.  
  280. (defun life-extinct-quit ()
  281.   (life-display-generation 0)
  282.   (signal 'life-extinct nil))
  283.  
  284. ;; XEmacs change
  285. (define-error 'life-extinct "All life has perished" 'quit)
  286.  
  287. (provide 'life)
  288.  
  289. ;;; life.el ends here
  290.